home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl_txt.lha / kcl-low.lisp next >
Lisp/Scheme  |  1993-08-13  |  13KB  |  389 lines
  1. ;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987 Xerox Corporation.  All rights reserved.
  5. ;;;
  6. ;;; Use and copying of this software and preparation of derivative works
  7. ;;; based upon this software are permitted.  Any distribution of this
  8. ;;; software or derivative works must comply with all applicable United
  9. ;;; States export control laws.
  10. ;;; 
  11. ;;; This software is made available AS IS, and Xerox Corporation makes no
  12. ;;; warranty about the software, its performance or its conformity to any
  13. ;;; specification.
  14. ;;; 
  15. ;;; Any person obtaining a copy of this software is requested to send their
  16. ;;; name and post office or electronic mail address to:
  17. ;;;   CommonLoops Coordinator
  18. ;;;   Xerox PARC
  19. ;;;   3333 Coyote Hill Rd.
  20. ;;;   Palo Alto, CA 94304
  21. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  22. ;;;
  23. ;;; Suggestions, comments and requests for improvements are also welcome.
  24. ;;; *************************************************************************
  25. ;;;
  26. ;;; The version of low for Kyoto Common Lisp (KCL)
  27. (in-package 'pcl)
  28.  
  29. ;;;
  30. ;;; The reason these are here is because the KCL compiler does not allow
  31. ;;; LET to return FIXNUM values as values of (c) type int, hence the use
  32. ;;; of LOCALLY (which expands into (LET () (DECLARE ...) ...)) forces
  33. ;;; conversion of ints to objects.
  34. ;;; 
  35. (defmacro %logand (&rest args)
  36.   (reduce-variadic-to-binary 'logand args 0 t 'fixnum))
  37.  
  38. (defmacro %logxor (&rest args)
  39.   (reduce-variadic-to-binary 'logxor args 0 t 'fixnum))
  40.  
  41. (defmacro %+ (&rest args)
  42.   (reduce-variadic-to-binary '+ args 0 t 'fixnum))
  43.  
  44. (defmacro %- (x y)
  45.   `(the fixnum (- (the fixnum ,x) (the fixnum ,y))))
  46.  
  47. (defmacro %* (&rest args)
  48.   (reduce-variadic-to-binary '* args 1 t 'fixnum))
  49.  
  50. (defmacro %/ (x y)
  51.   `(the fixnum (/ (the fixnum ,x) (the fixnum ,y))))
  52.  
  53. (defmacro %1+ (x)
  54.   `(the fixnum (1+ (the fixnum ,x))))
  55.  
  56. (defmacro %1- (x)
  57.   `(the fixnum (1- (the fixnum ,x))))
  58.  
  59. (defmacro %svref (vector index)
  60.   `(svref (the simple-vector ,vector) (the fixnum ,index)))
  61.  
  62. (defsetf %svref (vector index) (new-value)
  63.   `(setf (svref (the simple-vector ,vector) (the fixnum ,index))
  64.          ,new-value))
  65.  
  66.  
  67. ;;;
  68. ;;; iwmc-class-p
  69. ;;;
  70. (eval-when (compile eval load)
  71.  
  72. (si::freeze-defstruct 'iwmc-class)
  73.  
  74. (si:define-compiler-macro iwmc-class-p (x) `(typep ,x 'iwmc-class))
  75.  
  76. (setf (get 'cclosure-env 'compiler::inline-always)
  77.       (list '((t) t nil nil "(#0)->cc.cc_env")))
  78. )
  79. ;;;
  80. ;;; turbo-closure patch.  See the file kcl-mods.text for details.
  81. ;;;
  82. ;;; AKCL mods: DON'T use kcl-patches.lisp [replace it by an empty file ].
  83. ;;; Recent versions of akcl [since allocate-growth added] don't need any patch to c/gbc.c
  84. ;;; In earlier versions REMOVE the following line from c/gbc.c:
  85. ;;;        if (x->cc.cc_data->d.m) break;
  86. ;;; and (push :turbo-closure *features*)
  87.  
  88. #+akcl
  89. (eval-when (compile eval load)
  90. (if (fboundp 'si::allocate-growth) (pushnew :turbo-closure *features*))
  91. (setq compiler::*compile-ordinaries* t) 
  92. )
  93.  
  94. #+:turbo-closure
  95. (progn
  96. (CLines
  97.   "object tc_cc_env_nthcdr (n,tc)"
  98.   "object n,tc;                        "
  99.   "{return (type_of(tc)==t_cclosure&&  "
  100.   "         tc->cc.cc_turbo!=NULL&&    "
  101.   "         type_of(n)==t_fixnum)?     "
  102.   "         tc->cc.cc_turbo[fix(n)]:   " ; assume that n is in bounds
  103.   "         Cnil;                      "
  104.   "}                                   "
  105.   )
  106.  
  107. (defentry tc-cclosure-env-nthcdr (object object) (object tc_cc_env_nthcdr))
  108.  
  109. (setf (get 'tc-cclosure-env-nthcdr 'compiler::inline-unsafe)
  110.       '(((fixnum t) t nil nil "(#1)->cc.cc_turbo[#0]")))
  111. )
  112.  
  113.  
  114. ;;;; low level stuff to hack compiled functions and compiled closures.
  115. ;;;
  116. ;;; The primary client for this is fsc-low, but since we make some use of
  117. ;;; it here (e.g. to implement set-function-name-1) it all appears here.
  118. ;;;
  119.  
  120. (eval-when (compile eval)
  121.  
  122. (defmacro define-cstruct-accessor (accessor structure-type field value-type
  123.                         field-type tag-name)
  124.   (let ((setf (intern (concatenate 'string "SET-" (string accessor))))
  125.     (caccessor (format nil "pcl_get_~A_~A" structure-type field))
  126.     (csetf     (format nil "pcl_set_~A_~A" structure-type field))
  127.     (vtype (intern (string-upcase value-type))))
  128.     `(eval-when (compile eval load)
  129.        (CLines ,(format nil "~A ~A(~A)                ~%~
  130.                              object ~A;               ~%~
  131.                              { return ((~A) ~A->~A.~A); }       ~%~
  132.                                                       ~%~
  133.                              ~A ~A(~A, new)           ~%~
  134.                              object ~A;               ~%~
  135.                              ~A new;                  ~%~
  136.                              { return ((~A)(~A->~A.~A = ~Anew)); } ~%~
  137.                             "
  138.             value-type caccessor structure-type 
  139.             structure-type
  140.             value-type structure-type tag-name field
  141.             value-type csetf structure-type
  142.             structure-type 
  143.             value-type 
  144.             value-type structure-type tag-name field field-type
  145.             ))
  146.  
  147.        (defentry ,accessor (object) (,vtype ,caccessor))
  148.        (defentry ,setf (object ,vtype) (,vtype ,csetf))
  149.  
  150.  
  151.        (defsetf ,accessor ,setf)
  152.  
  153.        )))
  154. )
  155. ;;; 
  156. ;;; struct cfun {                   /*  compiled function header  */
  157. ;;;         short   t, m;
  158. ;;;         object  cf_name;        /*  compiled function name  */
  159. ;;;         int     (*cf_self)();   /*  entry address  */
  160. ;;;         object  cf_data;        /*  data the function uses  */
  161. ;;;                                 /*  for GBC  */
  162. ;;;         char    *cf_start;      /*  start address of the code  */
  163. ;;;         int     cf_size;        /*  code size  */
  164. ;;; };
  165. ;;; add field-type tag-name
  166. (define-cstruct-accessor cfun-name  "cfun" "cf_name"  "object" "(object)" "cf")
  167. (define-cstruct-accessor cfun-self  "cfun" "cf_self"  "int" "(int (*)())" 
  168.                          "cf")
  169. (define-cstruct-accessor cfun-data  "cfun" "cf_data"  "object" "(object)" "cf")
  170. #-akcl(define-cstruct-accessor cfun-start "cfun" "cf_start" "int" "(char *)" "cf")
  171. #-akcl(define-cstruct-accessor cfun-size  "cfun" "cf_size"  "int" "(int)" "cf")
  172.  
  173. (CLines
  174.   "object pcl_cfunp (x)              "
  175.   "object x;                         "
  176.   "{if(x->c.t == (int) t_cfun)       "
  177.   "  return (Ct);                    "
  178.   "  else                            "
  179.   "    return (Cnil);                "
  180.   "  }                               "
  181.   )
  182.  
  183. (defentry cfunp (object) (object pcl_cfunp))
  184.  
  185. ;;; 
  186. ;;; struct cclosure {               /*  compiled closure header  */
  187. ;;;         short   t, m;
  188. ;;;         object  cc_name;        /*  compiled closure name  */
  189. ;;;         int     (*cc_self)();   /*  entry address  */
  190. ;;;         object  cc_env;         /*  environment  */
  191. ;;;         object  cc_data;        /*  data the closure uses  */
  192. ;;;                                 /*  for GBC  */
  193. ;;;         char    *cc_start;      /*  start address of the code  */
  194. ;;;         int     cc_size;        /*  code size  */
  195. ;;; };
  196. ;;; 
  197. (define-cstruct-accessor cclosure-name "cclosure"  "cc_name"  "object"
  198.                          "(object)" "cc")          
  199. (define-cstruct-accessor cclosure-self "cclosure"  "cc_self"  "int" 
  200.                          "(int (*)())" "cc")
  201. (define-cstruct-accessor cclosure-data "cclosure"  "cc_data"  "object"
  202.                           "(object)" "cc")
  203. #-akcl
  204. (define-cstruct-accessor cclosure-start "cclosure" "cc_start" "int" 
  205.                          "(char *)" "cc")
  206. #-akcl
  207. (define-cstruct-accessor cclosure-size "cclosure"  "cc_size"  "int"
  208.              "(int)" "cc")
  209. #+akcl
  210. (progn
  211. (defmacro set-cclosure-start (x y) x y nil)
  212. (defmacro set-cclosure-size (x y) x y nil)
  213. )
  214.  
  215.  
  216. (define-cstruct-accessor cclosure-env "cclosure"   "cc_env"   "object"
  217.                          "(object)" "cc")
  218.  
  219.  
  220. (CLines
  221.   "object pcl_cclosurep (x)          "
  222.   "object x;                         "
  223.   "{if(x->c.t == (int) t_cclosure)   "
  224.   "  return (Ct);                    "
  225.   "  else                            "
  226.   "   return (Cnil);                 "
  227.   "  }                               "
  228.   )
  229.  
  230. (defentry cclosurep (object) (object pcl_cclosurep))
  231.  
  232.   ;;   
  233. ;;;;;; Load Time Eval
  234.   ;;
  235. ;;; 
  236.  
  237. ;;; This doesn't work because it looks at a global variable to see if it is
  238. ;;; in the compiler rather than looking at the macroexpansion environment.
  239. ;;; 
  240. ;;; The result is that if in the process of compiling a file, we evaluate a
  241. ;;; form that has a call to load-time-eval, we will get faked into thinking
  242. ;;; that we are compiling that form.
  243. ;;;
  244. ;;; THIS NEEDS TO BE DONE RIGHT!!!
  245. ;;; 
  246. ;(defmacro load-time-eval (form)
  247. ;  ;; In KCL there is no compile-to-core case.  For things that we are 
  248. ;  ;; "compiling to core" we just expand the same way as if were are
  249. ;  ;; compiling a file since the form will be evaluated in just a little
  250. ;  ;; bit when gazonk.o is loaded.
  251. ;  (if (and (boundp 'compiler::*compiler-input*)  ;Hack to see of we are
  252. ;       compiler::*compiler-input*)          ;in the compiler!
  253. ;      `'(si:|#,| . ,form)
  254. ;      `(progn ,form)))
  255.  
  256. (defmacro load-time-eval (form)
  257.   (read-from-string (format nil "'#,~S" form)))
  258.  
  259. (defmacro memory-block-ref (block offset)
  260.   `(svref (the simple-vector ,block) (the fixnum ,offset)))
  261.  
  262.   ;;   
  263. ;;;;;; Generating CACHE numbers
  264.   ;;
  265. ;;; This needs more work to be sure it is going as fast as possible.
  266. ;;;   -  The calls to si:address should be open-coded.
  267. ;;;   -  The logand should be open coded.
  268. ;;;   
  269.  
  270. ;(defmacro symbol-cache-no (symbol mask)
  271. ;  (if (and (constantp symbol)
  272. ;       (constantp mask))
  273. ;      `(load-time-eval (logand (ash (si:address ,symbol) -2) ,mask))
  274. ;      `(logand (ash (the fixnum (si:address ,symbol)) -2) ,mask)))
  275.  
  276.  
  277. (push '((t) fixnum nil nil "((int)(#0))") (get 'si::address 'compiler::inline-safe))
  278.  
  279.  
  280. (defmacro object-cache-no (object mask)
  281.   `(the fixnum (logand (the fixnum (si:address ,object)) (the fixnum ,mask))))
  282.  
  283.   ;;   
  284. ;;;;;; printing-random-thing-internal
  285.   ;;
  286. (defun printing-random-thing-internal (thing stream)
  287.   (format stream "~O" (si:address thing)))
  288.  
  289.  
  290. (defun set-function-name-1 (fn new-name ignore)
  291.   (cond ((cclosurep fn)
  292.      (setf (cclosure-name fn) new-name))
  293.     ((cfunp fn)
  294.      (setf (cfun-name fn) new-name))
  295.     ((and (listp fn)
  296.           (eq (car fn) 'lambda-block))
  297.      (setf (cadr fn) new-name))
  298.     ((and (listp fn)
  299.           (eq (car fn) 'lambda))
  300.      (setf (car fn) 'lambda-block
  301.            (cdr fn) (cons new-name (cdr fn)))))
  302.   fn)
  303.  
  304.  
  305.  
  306.  
  307. #|
  308. (defconstant most-positive-small-fixnum 1024)  /* should be supplied */
  309. (defconstant most-negative-small-fixnum -1024) /* by ibuki */
  310.  
  311. (defmacro symbol-cache-no (symbol mask)
  312.   (if (constantp mask)
  313.       (if (and (> mask 0)
  314.            (< mask most-positive-small-fixnum))
  315.       (if (constantp symbol)
  316.           `(load-time-eval (coffset ,symbol ,mask 2))
  317.         `(coffset ,symbol ,mask 2))
  318.     (if (constantp symbol)
  319.         `(load-time-eval 
  320.            (logand (ash (the fixnum (si:address ,symbol)) -2) ,mask))
  321.       `(logand (ash (the fixnum (si:address ,symbol)) -2) ,mask)))
  322.     `(logand (ash (the fixnum (si:address ,symbol)) -2) ,mask)))
  323.  
  324.  
  325. (defmacro object-cache-no (object mask)
  326.   (if (and (constantp mask)
  327.        (> mask 0)
  328.        (< mask most-positive-small-fixnum))
  329.       `(coffset ,object ,mask 4)
  330.     `(logand (ash (the fixnum (si:address ,object)) -4) ,mask)))
  331.  
  332. (CLines
  333.   "object pcl_coffset (sym,mask,lshift)"
  334.   "object sym,mask,lshift;"
  335.   "{"
  336.   "    return(small_fixnum(((int)sym >> fix(lshift)) & fix(mask)));"
  337.   "}"
  338.   )
  339.  
  340. (defentry coffset (object object object) (object pcl_coffset))
  341.  
  342.  
  343. |#
  344.  
  345. #|
  346. Instructions for compilation of pcl in AKCL 
  347.  
  348. * ftp the new (ie this file) kcl-low.lisp file from rascal
  349. (128.83.144.1) and put it in your pcl directory.
  350.  
  351. % cd pcl
  352. % akcl
  353.  
  354. ;; Now to compile pcl evaluate the following forms:
  355.  
  356. (load "defsys.lisp")
  357. (setq pcl::*pathname-extensions* '("lisp" . "o"))
  358. (setq pcl::*pcl-directory* (truename "./"))
  359. (or (probe-file "kcl-patches.lisp-")  ;replace kcl-patches.lisp by empty file
  360.     (system "mv kcl-patches.lisp kcl-patches.lisp- ; echo > kcl-patches.lisp"))
  361. (pcl::compile-pcl)
  362.  
  363.  
  364. ;; It should compile without error.  To test:
  365.  
  366. % cd pcl
  367. % akcl
  368.  
  369. (load "defsys.lisp")
  370. (setq pcl::*pathname-extensions* '("lisp" . "o"))
  371. (setq pcl::*pcl-directory* (truename "./"))
  372. (pcl::load-pcl)
  373. (load "test.lisp")
  374.  
  375.  
  376. ------------------------------------
  377.  
  378.  
  379. There is a note in the kcl-low.lisp file about a change for gbc.c in akcl
  380. versions prior to 265.
  381. [The change is to remove  "if (x->cc.cc_data->d.m) break;" ].
  382.  
  383. This is an optimization and is not necessary, so you may as well wait
  384. till you get a newer version of akcl, in which case you won't have to
  385. do anything.
  386. |#
  387.  
  388.  
  389.